home *** CD-ROM | disk | FTP | other *** search
/ FishMarket 1.0 / FishMarket v1.0.iso / fishies / 551-575 / disk_556 / scheme2c / scheme-doc.lzh / cdecl / extern.sc < prev    next >
Text File  |  1991-10-11  |  9KB  |  265 lines
  1. ;;; C declaration compiler.
  2.  
  3. ;*              Copyright 1989 Digital Equipment Corporation
  4. ;*                         All Rights Reserved
  5. ;*
  6. ;* Permission to use, copy, and modify this software and its documentation is
  7. ;* hereby granted only under the following terms and conditions.  Both the
  8. ;* above copyright notice and this permission notice must appear in all copies
  9. ;* of the software, derivative works or modified versions, and any portions
  10. ;* thereof, and both notices must appear in supporting documentation.
  11. ;*
  12. ;* Users of this software agree to the terms and conditions set forth herein,
  13. ;* and hereby grant back to Digital a non-exclusive, unrestricted, royalty-free
  14. ;* right and license under any changes, enhancements or extensions made to the
  15. ;* core functions of the software, including but not limited to those affording
  16. ;* compatibility with other hardware or software environments, but excluding
  17. ;* applications which incorporate this software.  Users further agree to use
  18. ;* their best efforts to return to Digital any such changes, enhancements or
  19. ;* extensions that they make and inform Digital of noteworthy uses of this
  20. ;* software.  Correspondence should be provided to Digital at:
  21. ;* 
  22. ;*                       Director of Licensing
  23. ;*                       Western Research Laboratory
  24. ;*                       Digital Equipment Corporation
  25. ;*                       100 Hamilton Avenue
  26. ;*                       Palo Alto, California  94301  
  27. ;* 
  28. ;* This software may be distributed (but not offered for sale or transferred
  29. ;* for compensation) to third parties, provided such third parties agree to
  30. ;* abide by the terms and conditions of this notice.  
  31. ;* 
  32. ;* THE SOFTWARE IS PROVIDED "AS IS" AND DIGITAL EQUIPMENT CORP. DISCLAIMS ALL
  33. ;* WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF
  34. ;* MERCHANTABILITY AND FITNESS.   IN NO EVENT SHALL DIGITAL EQUIPMENT
  35. ;* CORPORATION BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL
  36. ;* DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR
  37. ;* PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS
  38. ;* ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
  39. ;* SOFTWARE.
  40.  
  41. ;;; This module compiles "extern" forms which define C library procedures.
  42. ;;;
  43. ;;;    <extern> ::= ( EXTERN <type> <fname> [ <arg> ... ] )
  44. ;;;
  45. ;;;    <fname>  ::= a Scheme string
  46. ;;;
  47. ;;;    <arg>     ::= ( <type> <id> )
  48. ;;;             ( IN <type> <id> )
  49. ;;;             ( OUT <type> <id> )
  50. ;;;             ( IN_OUT <type> <id> )
  51. ;;;
  52. ;;;    <id>     ::= a Scheme symbol
  53.  
  54. (module extern)
  55.  
  56. ;;; The following function syntax checks an extern expression.  It will either
  57. ;;; report an error, or return the expression as its value.
  58.  
  59. (define (INPUT-EXTERN exp)
  60.     (if (and (>= (length exp) 3)
  61.          (parse-type (cadr exp))
  62.          (string? (caddr exp)))
  63.     (begin (for-each parse-arg (cdddr exp))
  64.            exp)
  65.     (error 'input-extern "Illegal EXTERN syntax: ~s" exp)))
  66.  
  67. ;;; Parses the argument list and calls error on an error.
  68.  
  69. (define (PARSE-ARG exp)
  70.     (if (and (pair? exp)
  71.          (or (and (= (length exp) 2)
  72.               (parse-type (car exp))
  73.               (symbol? (cadr exp)))
  74.          (and (= (length exp) 3)
  75.               (memq (car exp) '(in out in_out))
  76.               (parse-type (cadr exp))
  77.               (symbol? (caddr exp)))))
  78.     #t
  79.     (error 'PARSE-ARG "Illegal ARGUMENT syntax: ~s" exp)))
  80.  
  81. ;;; Code is generated by the following function.
  82.  
  83. (define (EMIT-EXTERNS externs extern-file-root type-file-root)
  84.     (let ((module (uis extern-file-root)))
  85.      (with-output-to-file
  86.          (string-append extern-file-root ".sc")
  87.          (lambda ()
  88.              (write `(module ,module))
  89.              (newline)
  90.              (write `(include ,(string-append type-file-root ".sch")))
  91.              (newline)
  92.              (for-each (lambda (x) (emit-extern x 'define)) externs)))
  93.      (with-output-to-file
  94.          (string-append extern-file-root ".sch")
  95.          (lambda ()
  96.              (for-each (lambda (x) (emit-define-external x module))
  97.              externs)))))
  98.  
  99. ;;; The definition for the interface procedure for an extern is created by
  100. ;;; the following procedure.
  101.  
  102. (define (EMIT-EXTERN extern defform)
  103.     (let ((xname (uis (caddr extern) "*"))
  104.       (rettype (cadr extern))
  105.       (args (cdddr extern)))
  106.      
  107.      (define (EMIT-CALL)
  108.          `(,xname ,@(map (lambda (x) (car (last-pair x))) args)))
  109.      
  110.      (define (FORMALS args)
  111.          (if args
  112.              (if (eq? (caar args) 'out)
  113.              (formals (cdr args))
  114.              (cons (car (last-pair (car args)))
  115.                    (formals (cdr args))))
  116.              '()))
  117.      
  118.      (pp `(define-c-external
  119.           (,xname ,@(map simple-type args))
  120.           ,(simple-type (list rettype 'returned))
  121.           ,(caddr extern)))
  122.      (newline)
  123.      (pp `(,defform (,(uis (caddr extern)) ,@(formals args))
  124.            (let* (,@(map arg-in args)
  125.               (return-value
  126.               ,(cond ((eq? rettype 'void)
  127.                   `(begin ,(emit-call) #f))
  128.                  ((eq? rettype 'string)
  129.                   `(c-string->string ,(emit-call)))
  130.                  ((isa-pointer? rettype)
  131.                   `(cons ',(base-type rettype)
  132.                      ,(emit-call)))
  133.                  (else (emit-call)))))
  134.              ,(let ((out (args-out args)))
  135.                (if out
  136.                    (if (eq? rettype 'void)
  137.                    (if (= (length out) 1)
  138.                        (car out)
  139.                        `(list ,@out))
  140.                    `(list return-value ,@out))
  141.                    'return-value)))))
  142.      (newline)))
  143.  
  144. ;;; Called to do input conversion for arguments.  Return an expression
  145. ;;; of th form (<var> <value>).
  146.  
  147. (define (ARG-IN arg)
  148.     (let* ((flag (if (memq (car arg) '(in out in_out))
  149.              (car arg)
  150.              #f))
  151.        (type (if flag (cadr arg) (car arg)))
  152.        (var  (if flag (caddr arg) (cadr arg))))
  153.       (case flag
  154.         ((in) `(,var (in->c ,var)))
  155.         ((in_out) `(,var (in_out->c ,var)))
  156.         ((out) `(,var (make-string ,(if (eq? type 'string)
  157.                            4
  158.                            (size-of type)))))
  159.         (else (cond ((eq? type 'string)
  160.                  `(,var (if (string? ,var)
  161.                     ,var
  162.                     (error 'chk-string
  163.                            "Argument is incorrect type: ~s"
  164.                         ,var))))
  165.                 ((isa-pointer? type)
  166.                  `(,var (,(uis "CHK-" (base-type type)) ,var)))
  167.                 (else  `(,var ,var)))))))
  168.  
  169. ;;; Return a list of the expressions required to do output conversion after
  170. ;;; an external call.
  171.      
  172. (define (ARGS-OUT args)
  173.     
  174.     (define (ARG-OUT arg)
  175.         (let* ((flag (if (memq (car arg) '(in out in_out))
  176.                  (car arg)
  177.                  #f))
  178.            (type (if flag (cadr arg) (car arg)))
  179.            (var  (if flag (caddr arg) (cadr arg))))
  180.           (case flag
  181.             ((in) #f)
  182.             ((in_out) `(c->in_out ,var))
  183.             ((out)
  184.              (cond ((eq? type 'string)
  185.                 `(c-string->string (c-unsigned-ref ,var 0)))
  186.                    ((isa-pointer? type)
  187.                 `(cons ',(base-type type)
  188.                        (c-unsigned-ref ,var 0)))
  189.                    ((or (isa-union? type) (isa-struct? type)
  190.                     (isa-array? type))
  191.                 `(cons ',(pointed-to-by type) ,var))
  192.                    (else `(,(getprop (base-type type) 'to-get)
  193.                        ,var 0))))
  194.             (else #f))))
  195.  
  196.     (if args
  197.     (let ((out (arg-out (car args))))
  198.          (if out
  199.          (cons out (args-out (cdr args)))
  200.          (args-out (cdr args))))
  201.     '()))
  202.  
  203. ;;; Converts the type of a procedure argument to a simple C-type.
  204.  
  205. (define (SIMPLE-TYPE type)
  206.     (cond ((memq (car type) '(in out in_out string)) 'pointer)
  207.       ((eq? (car type) 'void) 'void)
  208.       ((isa-pointer? (car type)) 'pointer)
  209.       ((isa-procp? (car type)) 'pointer)
  210.       (else (base-type (car type)))))
  211.  
  212. ;;; The STUBS file is written by the following function.
  213.  
  214. (define (EMIT-STUBS externs stubs-file-root)
  215.     (with-output-to-file
  216.     (string-append stubs-file-root ".sc")
  217.     (lambda ()
  218.         (write `(module ,(uis stubs-file-root)))
  219.         (newline)
  220.         (for-each emit-stub externs))))
  221.  
  222. ;;; The external definition for a procedure is written by the following
  223. ;;; function.
  224.  
  225. (define (EMIT-DEFINE-EXTERNAL extern module)
  226.     (let ((formals (let loop ((args (cdddr extern))
  227.                   (formals '(a b c d e f g h i j k l m
  228.                        n o p q r s t u v w x y z)))
  229.             (cond ((null? args) '())
  230.                   ((eq? (caar args) 'out)
  231.                    (loop (cdr args) (cdr formals)))
  232.                   (else (cons (car formals)
  233.                       (loop (cdr args) (cdr formals))))))))
  234.      
  235.      (pp `(define-external (,(uis (caddr extern)) ,@formals) ,module))
  236.      (newline)))
  237.  
  238. ;;; The definition for a stub procedure is written by the following function.
  239.  
  240. (define (EMIT-STUB extern)
  241.     (let* ((c-name (uis (caddr extern) "**"))
  242.        (stub-name (uis (caddr extern) "*"))
  243.        (rettype (cadr extern))
  244.        (args (cdddr extern))
  245.        (formals (let loop ((args args)
  246.                    (formals '(a b c d e f g h i j k l m
  247.                         n o p q r s t u v w x y z)))
  248.              (if (not (null? args))
  249.                  (cons (car formals)
  250.                    (loop (cdr args) (cdr formals)))
  251.                  '()))))
  252.       
  253.       (pp `(define-c-external
  254.            (,c-name ,@(map simple-type args))
  255.            ,(simple-type (list rettype 'returned))
  256.            ,(caddr extern)))
  257.       (newline)
  258.       (pp `(define (,stub-name ,@formals)
  259.                (,c-name ,@formals)
  260.                ,@(if (eq? rettype 'void) '(#f) '())))
  261.       (newline)))
  262.  
  263.                      
  264.                      
  265.